; ORIGINAL: 3dt2.1/examples/viewmod.scm
; ORIGINAL: 3dt2.1/examples/viewmod.scm
; $Id: viewmod.scm,v 1.4 1996/10/21 15:59:45 aed Exp $
;- viewmod.scm -----------------------------------------------------
; Perform interactive modification of views.
; Button 1 performs spherical rotation about the target position
; Button 2 pans the view in X and Y
; Button 3 zooms the view
; (viewmod #t) turns on interaction. and (viewmod #f) turns off interaction.
;------------------------------------------------------------------

(require 'math "math.scm")
(require 'old-rb "old-rb.scm")

(define zoom-step 0.1)

(define viewmod
  (lambda (onoff)
    (let* ((orig-view #f)
		   (orig-y 0)
		   (orig-width 0)
		   (orig-height 0)
		   (button 0)
		   (radius 1)
		   (sil_status #f)
           (prev-event #f))
      (if onoff
        ;; TRUE: Define mouse hooks for tracking position
        (begin
          ;; When button pressed, save original view info & start tracking
          (set! mouse-down-hook
            (lambda (pe)
			  (if (= button 0)
                (begin
                  (set! orig-view (event:view pe))
				  (set! orig-width (view:width orig-view))
				  (set! orig-height (view:height orig-view))
				  (set! radius (/ (min orig-width orig-height) 6.4))
                  (set! sil_status (dl:dynamic-silhouette-display #f))
                  (rb:scheme #t)
				)
                (rb-update-hook pe)
              )
			  (set! orig-y (event:y pe))
              (set! prev-event pe)
              (set! button (+ (if (event:left?   pe) 1 0)
			                  (if (event:middle? pe) 2 0)
							  (if (event:right?  pe) 4 0)))
            )
          )
          ;; As mouse moves, update view and refresh
          (set! rb-update-hook
            (lambda (pe)
              (if (> button 0)
                (let* ((vt (view:target orig-view))
                		(ve (view:eye orig-view))
						(vn (gvector:from-to vt ve))
						(p1 (pick:position prev-event vt vn))
						(p2 (pick:position pe vt vn))
						(v1 (gvector:from-to p1 p2)))
				  (cond
					((or (= button 1) (= button 6))
					  (let* ((p3 (position:project-to-line vt p1 v1))
						     (d3 (min (position:distance vt p3) radius))
						     (h (sqrt (- (* radius radius) (* d3 d3))))
						     (v2 (gvector:scale (gvector:unitize vn) h))
						     (p4 (position:offset p1 v2))
						     (v4 (gvector:from-to vt p4))
						     (axis (gvector:cross v1 v4))
						     (angle (radians->degrees (/ (gvector:length v1)
								     (max (position:distance vt p3) radius)))))
                        (view:set-eye (position:transform ve
                            (transform:rotation vt axis angle)) orig-view)
                        (view:set-up (gvector:transform (view:up orig-view)
                            (transform:rotation (position 0 0 0) axis angle))
					        orig-view)
					))
					((or (= button 2) (= button 5))
					  (let ((trans (transform:translation
								(gvector:reverse v1))))
					    (view:set-target (position:transform vt trans) orig-view)
					    (view:set-eye (position:transform ve trans) orig-view)
					))
					((or (= button 4) (= button 3))
					  (if (view:perspective?)
					    (let ((trans (transform:translation
								  (gvector:scale vn (* zoom-step
								  (- (event:y pe) (event:y prev-event)))))))
					      (view:set-target (position:transform vt trans)
									orig-view)
					      (view:set-eye (position:transform ve trans) orig-view)
						)
						(let* ((delta (* zoom-step (- (event:y pe) orig-y)))
							   (factor (if (positive? delta)
									     (+ 1 delta)
									     (/ 1 (- 1 delta)))))
						  (view:set-size (* orig-width factor)
									     (* orig-height factor)
									     orig-view)
						)
					))
				  )
                  (view:refresh orig-view)
				  (view:draw-point (view:target orig-view) orig-view)
                  (set! prev-event pe)
                )
              )
            )
          )
          ;; When button released, stop tracking
          (set! mouse-up-hook
            (lambda (pe)
			  (if (> button 0)
                (let ((new-button (- button (expt 2 (- (event:button pe) 1)))))
                  (if (= new-button 0)
                    (begin
                      (rb:scheme #f)
                      (dl:dynamic-silhouette-display sil_status)
                    )
                  )
                  (rb-update-hook pe)
			      (set! orig-y (event:y pe))
                  (set! prev-event pe)
			      (set! button new-button)
                )
              )
            )
          )
        )
        ;; FALSE: Turn off tracking capability
        (begin
          (set! mouse-down-hook '())
          (set! mouse-up-hook '())
          (set! rb-update-hook '())
        )
      )
      ;; Return the new setting
      onoff
    )
  )
)
